Exercicício 02
Instalando as bibliotecas
pacotes <- c("plotly","tidyverse","knitr","kableExtra","car","rgl","gridExtra",
"PerformanceAnalytics","reshape2","rayshader","psych","ggrepel",
"factoextra","sp","tmap","magick","gridExtra")
if(sum(as.numeric(!pacotes %in% installed.packages())) != 0){
instalador <- pacotes[!pacotes %in% installed.packages()]
for(i in 1:length(instalador)) {
install.packages(instalador, dependencies = T)
break()}
sapply(pacotes, require, character = T)
} else {
sapply(pacotes, require, character = T)
}## plotly tidyverse knitr
## TRUE TRUE TRUE
## kableExtra car rgl
## TRUE TRUE TRUE
## gridExtra PerformanceAnalytics reshape2
## TRUE TRUE TRUE
## rayshader psych ggrepel
## TRUE TRUE TRUE
## factoextra sp tmap
## TRUE TRUE TRUE
## magick gridExtra
## TRUE TRUEProposta de estudo de validação de constructos
load("percepcao_lojas.RData")Questionário proposto
questionario <- image_read("questionário.png")
plot(questionario)
Apresentando a base de dados:
percepcao_lojas ## # A tibble: 1,400 x 8
## sortimento reposição layout conforto limpeza atendimento preço desconto
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 10 6.88 5.48 6.60 5.73 2.05 1.58 2.76
## 2 6.05 4.76 6.44 6.44 6.09 1.17 4.43 6.23
## 3 5.45 4.65 5.34 6.16 5.72 2.34 4.10 5.38
## 4 6.09 5.03 6.25 5.96 5.56 2.34 3.61 5.01
## 5 5.44 4.85 5.14 6.30 5.98 0.287 3.64 4.68
## 6 5.27 4.55 5.08 6.16 5.27 1.02 4.25 5.65
## 7 7.31 5.28 8.43 8.37 7.99 1.61 5.39 6.50
## 8 5.97 4.50 6.54 6.02 5.08 1.90 4.48 6.10
## 9 5.70 4.76 5.74 6.33 5.89 0.873 4.40 6.20
## 10 6.36 5.06 6.76 6.16 6.03 2.19 4.39 6.11
## # … with 1,390 more rowsAnalisando as correlações entre variáveis da base de dados percepcao_lojas
chart.Correlation(percepcao_lojas, histogram = TRUE)
Salvando a Matriz de Correlações
rho_lojas <- cor(percepcao_lojas)Construindo um mapa de calor a partir das correlações
plot2d_rho_lojas <-rho_lojas %>%
melt() %>%
ggplot() +
geom_tile(aes(x = Var1, y = Var2, fill = value)) +
geom_text(aes(x = Var1, y = Var2, label = round(x = value, digits = 3)),
size = 4) +
labs(x = NULL,
y = NULL,
fill = "Correlações") +
scale_fill_gradient2(low = "dodgerblue4",
mid = "white",
high = "brown4",
midpoint = 0) +
theme(panel.background = element_rect("white"),
panel.grid = element_line("grey95"),
panel.border = element_rect(NA),
legend.position = "bottom",
axis.text.x = element_text(angle = 0))
plot2d_rho_lojas
Visualizando o plot 3D
O teste de efericidade de Bartlett
cortest.bartlett(R = rho_lojas)## Warning in cortest.bartlett(R = rho_lojas): n not specified, 100 used## $chisq
## [1] 941.172
##
## $p.value
## [1] 3.883815e-180
##
## $df
## [1] 28O algoritmo prcomp(), do pacote psych, EXIGE que a a matriz de dados fornecida a ele já esteja padronizada pelo procedimento zscores:
percepcao_lojas_std <- percepcao_lojas %>%
scale() %>%
data.frame()Rodando a PCA
afpc_lojas <- prcomp(percepcao_lojas_std)
summary(afpc_lojas)## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 1.9558 1.5013 0.9713 0.77243 0.46291 0.3544 0.15827
## Proportion of Variance 0.4781 0.2817 0.1179 0.07458 0.02679 0.0157 0.00313
## Cumulative Proportion 0.4781 0.7599 0.8778 0.95238 0.97917 0.9949 0.99799
## PC8
## Standard deviation 0.12665
## Proportion of Variance 0.00201
## Cumulative Proportion 1.00000Sumarizando pontos importantes:
data.frame(eigenvalue = afpc_lojas$sdev ^ 2,
var_compartilhada = summary(afpc_lojas)$importance[2,],
var_cumulativa = summary(afpc_lojas)$importance[3,]) -> relatorio_lojas
relatorio_lojas## eigenvalue var_compartilhada var_cumulativa
## PC1 3.82498900 0.47812 0.47812
## PC2 2.25391334 0.28174 0.75986
## PC3 0.94350507 0.11794 0.87780
## PC4 0.59664723 0.07458 0.95238
## PC5 0.21428491 0.02679 0.97917
## PC6 0.12556987 0.01570 0.99486
## PC7 0.02504948 0.00313 0.99799
## PC8 0.01604110 0.00201 1.00000Visualizando os pesos que cada variável tem em cada componente principal obtido pela PCA
ggplotly(
data.frame(afpc_lojas$rotation) %>%
mutate(var = names(percepcao_lojas)) %>%
melt(id.vars = "var") %>%
mutate(var = factor(var)) %>%
ggplot(aes(x = var, y = value, fill = var)) +
geom_bar(stat = "identity", color = "black") +
facet_wrap(~variable) +
labs(x = NULL, y = NULL, fill = "Legenda:") +
scale_fill_viridis_d() +
theme_bw() +
theme(axis.text.x = element_text(angle = 90))
)Extraindo as Cargas Fatoriais
k <- sum((afpc_lojas$sdev ^ 2) > 1)
cargas_fatoriais <- afpc_lojas$rotation[, 1:k] %*% diag(afpc_lojas$sdev[1:k])Visualizando as cargas fatoriais
data.frame(cargas_fatoriais) %>%
rename(F1 = X1,
F2 = X2) ## F1 F2
## sortimento -0.9179228 0.17358884
## reposição -0.6921685 0.65956728
## layout -0.8552432 -0.18455871
## conforto -0.9090551 0.02924618
## limpeza -0.8488383 0.01020367
## atendimento -0.3105135 -0.06475223
## preço -0.2736408 -0.95034455
## desconto -0.2316529 -0.91999037Visualizando as Comunalidades
data.frame(rowSums(cargas_fatoriais ^ 2)) %>%
rename(comunalidades = 1) ## comunalidades
## sortimento 0.8727153
## reposição 0.9141263
## layout 0.7655028
## conforto 0.8272365
## limpeza 0.7206306
## atendimento 0.1006115
## preço 0.9780340
## desconto 0.9000454Relatório das cargas fatoriais e das comunalidades
data.frame(cargas_fatoriais) %>%
rename(F1 = X1,
F2 = X2) %>%
mutate(Comunalidades = rowSums(cargas_fatoriais ^ 2)) ## F1 F2 Comunalidades
## sortimento -0.9179228 0.17358884 0.8727153
## reposição -0.6921685 0.65956728 0.9141263
## layout -0.8552432 -0.18455871 0.7655028
## conforto -0.9090551 0.02924618 0.8272365
## limpeza -0.8488383 0.01020367 0.7206306
## atendimento -0.3105135 -0.06475223 0.1006115
## preço -0.2736408 -0.95034455 0.9780340
## desconto -0.2316529 -0.91999037 0.9000454Note que, tanto as cargas fatoriais quanto a comunalidade da variável atendimento são relativamente baixas. Tal situação pode evidenciar a necessidade da extração de um terceiro fator, descaracterizando o critério da raiz latente:
Extraindo as Cargas Fatoriais para os 3 Fatores
k <- length(afpc_lojas$sdev[1:3])
cargas_fatoriais <- afpc_lojas$rotation[, 1:k] %*% diag(afpc_lojas$sdev[1:k])Visualizando as cargas fatoriais
data.frame(cargas_fatoriais) %>%
rename(F1 = X1,
F2 = X2,
F3 = X3)## F1 F2 F3
## sortimento -0.9179228 0.17358884 0.119311288
## reposição -0.6921685 0.65956728 -0.050840580
## layout -0.8552432 -0.18455871 0.195862787
## conforto -0.9090551 0.02924618 0.021148058
## limpeza -0.8488383 0.01020367 0.032634707
## atendimento -0.3105135 -0.06475223 -0.941641098
## preço -0.2736408 -0.95034455 0.010633819
## desconto -0.2316529 -0.91999037 0.003096998Visualizando as Comunalidades
data.frame(rowSums(cargas_fatoriais ^ 2)) %>%
rename(comunalidades = 1)## comunalidades
## sortimento 0.8869505
## reposição 0.9167110
## layout 0.8038651
## conforto 0.8276837
## limpeza 0.7216956
## atendimento 0.9872994
## preço 0.9781471
## desconto 0.9000550Relatório das cargas fatoriais e das comunalidades
data.frame(cargas_fatoriais) %>%
rename(F1 = X1,
F2 = X2,
F3 = X3) %>%
mutate(Comunalidades = rowSums(cargas_fatoriais ^ 2)) ## F1 F2 F3 Comunalidades
## sortimento -0.9179228 0.17358884 0.119311288 0.8869505
## reposição -0.6921685 0.65956728 -0.050840580 0.9167110
## layout -0.8552432 -0.18455871 0.195862787 0.8038651
## conforto -0.9090551 0.02924618 0.021148058 0.8276837
## limpeza -0.8488383 0.01020367 0.032634707 0.7216956
## atendimento -0.3105135 -0.06475223 -0.941641098 0.9872994
## preço -0.2736408 -0.95034455 0.010633819 0.9781471
## desconto -0.2316529 -0.91999037 0.003096998 0.9000550Note que a decisão de extração de três fatores, em detrimento da extração com base no critério da raiz latente, aumenta as comunalidades das variáveis, com destaque para a variável atendimento, agora correlacionada mais fortemente com o terceiro fator.
Comportamento das cargas fatoriais de forma 2D (usando F1 e F2)
data.frame(cargas_fatoriais) %>%
rename(F1 = X1,
F2 = X2,
F3 = X3) -> cargas_fatoriaisATENÇÃO! OS SINAIS NEGATIVOS PARA A PLOTAGEM DE F2, SERVEM ÚNICA E EXCLUSIVAMENTE PARA INVERTER OS EIXOS DO GRÁFICO E PERMITIR A SUBSEQUENTE COMPARAÇÃO COM O PLOT 3D.
cargas_fatoriais %>%
ggplot(aes(x = -F2, y = F1)) +
geom_point(color = "orange") +
geom_hline(yintercept = 0, color = "darkorchid") +
geom_vline(xintercept = 0, color = "darkorchid") +
geom_text_repel(label = row.names(cargas_fatoriais)) +
theme_bw() 
Comportamento das cargas fatoriais de forma 3D (usando F1, F2 e F3)
afpc_lojas_3D <- plot_ly()
afpc_lojas_3D <- add_trace(p = afpc_lojas_3D,
x = cargas_fatoriais$F2,
y = cargas_fatoriais$F3,
z = cargas_fatoriais$F1,
mode = 'text',
text = rownames(cargas_fatoriais),
textfont = list(color = "orange"),
showlegend = FALSE)
afpc_lojas_3D <- layout(p = afpc_lojas_3D,
scene = list(xaxis = list(title = colnames(cargas_fatoriais)[2]),
yaxis = list(title = colnames(cargas_fatoriais)[3]),
zaxis = list(title = colnames(cargas_fatoriais)[1]),
aspectmode = "data"))
afpc_lojas_3D## No trace type specified:
## Based on info supplied, a 'scatter3d' trace seems appropriate.
## Read more about this trace type -> https://plotly.com/r/reference/#scatter3d